home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / (A)Z / (A)Z11.ADF / Scheme / dump.scm < prev    next >
Text File  |  1988-03-01  |  7KB  |  243 lines
  1. ;;; dump.scm
  2.  
  3. ;;; (Use of this file may be hazardous to your garbage collector!!!)
  4.  
  5. ;;;
  6. ;;; Object TAGS are in bits 31:28
  7. ;;;
  8.  
  9. (define TAG_PAIR        #x00)    ; cdr offset = 0, car offset = 4
  10. (define TAG_STREAM        #x01)    ; pair underneath
  11. (define TAG_ENV         #x02)    ; pair underneath
  12. (define TAG_CLOSURE        #x03)    ; pair underneath
  13. (define TAG_VECTOR        #x04)    ; size, byte_size, ref, ref, ...
  14. (define TAG_NUMBER        #x05)    ; constant or pointer to rawdata in 23:0
  15. (define TAG_STRING        #x06)    ; size, char, char, ...
  16. (define TAG_PORT        #x07)    ; subtagged, value stored in bits 23:0
  17. (define TAG_SMALLCONST        #x08)    ; small constants -- see below
  18. (define TAG_SYMBOL        #x09)    ; index into symbol list
  19. (define TAG_EOF_OBJECT        #x0A)    ; point ptr in 24:0, but don't reuse it
  20. (define TAG_ENIGMA        #x0B)    ; for "boxed" values; value in bits 23:0
  21. (define TAG_STORAGE        #x0C)    ; "scrap" memory -- unspecified format
  22. ; --- no tag $0D
  23. ; --- no tag $0E
  24. (define TAG_RAWDATA        #x0F)    ; raw data in heap; size in bits 23:0
  25.  
  26. (define TAG_IMPOSSIBLE        TAG_SMALLCONST) ; marks gc forwarding pointers
  27. (define TAG_UNIT        TAG_SMALLCONST)
  28. (define TAG_EMPTY_LIST        TAG_SMALLCONST)
  29. (define TAG_EMPTY_STREAM    TAG_SMALLCONST)
  30. (define TAG_CHARACTER        TAG_SMALLCONST) ; character in bits 7:0
  31. (define TAG_BOOLEAN        TAG_SMALLCONST)
  32. (define TAG_STACK_MARKER    TAG_SMALLCONST) ; don't store this anywhere!!!
  33.  
  34.  
  35. ;;;
  36. ;;; Subtags are in bits 27:24
  37. ;;;
  38.  
  39. (define SC_SUBTAG_IMPOSSIBLE    #x00)
  40. (define SC_SUBTAG_UNIT        #x01)
  41. (define SC_SUBTAG_EMPTY_LIST    #x02)
  42. (define SC_SUBTAG_EMPTY_STREAM    #x03)
  43. (define SC_SUBTAG_CHARACTER    #x04)
  44. (define SC_SUBTAG_BOOLEAN    #x05)
  45. (define SC_SUBTAG_STACK_MARKER    #x06)
  46.  
  47. (define CL_SUBTAG_UNSPECIFIED    #x00)
  48. (define CL_SUBTAG_PRIMITIVE    #x01)
  49. (define CL_SUBTAG_PROCEDURE    #x02)
  50. (define CL_SUBTAG_COMPILED    #x03)
  51. (define CL_SUBTAG_THUNK     #x04)
  52. (define CL_SUBTAG_PROMISE    #x05)
  53. (define CL_SUBTAG_CONTINUATION    #x06)
  54.  
  55. (define NUM_SUBTAG_CONSTANT    #x00)    ; signed value stored in bits 15:0
  56. (define NUM_SUBTAG_FIXNUM    #x01)    ; pointer to rawdata holding a longword
  57. (define NUM_SUBTAG_RATNUM    #x02)    ; not currently used
  58. (define NUM_SUBTAG_BIGNUM    #x03)    ;  "     "       "
  59. (define NUM_SUBTAG_FLONUM    #x04)    ;  "     "       "
  60. (define NUM_SUBTAG_NUMBER_PAIR    #x05)    ;  "     "       "
  61.  
  62.  
  63. (define tag-name
  64.   (vector
  65.     'TAG_PAIR
  66.     'TAG_STREAM
  67.     'TAG_ENV
  68.     'TAG_CLOSURE
  69.     'TAG_VECTOR
  70.     'TAG_NUMBER
  71.     'TAG_STRING
  72.     'TAG_PORT
  73.     'TAG_SMALLCONST
  74.     'TAG_SYMBOL
  75.     'TAG_EOF_OBJECT
  76.     'TAG_ENIGMA
  77.     'TAG_STORAGE
  78.     '*UNKNOWN-TAG*
  79.     '*UNKNOWN-TAG*
  80.     'TAG_RAWDATA))
  81.  
  82.  
  83.  
  84. (define closure? procedure?)
  85.  
  86. (define (call-with-tag&subtag&ref obj proc)
  87.   (let ((rep (obj->rep obj)))
  88.     (call-with-quotient&remainder (car rep) #x10
  89.       (lambda (tag subtag)
  90.     (proc tag subtag (cdr rep))))))
  91.  
  92. (define (dump-obj-rep obj)
  93.   (call-with-tag&subtag&ref obj
  94.     (lambda (tag subtag ref)
  95.       (list tag (vector-ref tag-name tag) subtag ref))))
  96.  
  97.  
  98. (define (error-if-not-closure obj)
  99.   (if (not (closure? obj))
  100.       (error "object not a closure" obj)))
  101.  
  102.  
  103.  
  104. (define (closure-params closure)
  105.   (error-if-not-closure closure)
  106.   (dump-obj-rep (!storage-ref closure 1)))
  107.  
  108.  
  109.  
  110. (define (compound-procedure-params proc)
  111.   (if (compound-procedure? proc)
  112.       (!storage-ref proc 1)
  113.       (error "object not a compound procedure" proc)))
  114.  
  115. (define (compound-procedure-body proc)
  116.   (if (compound-procedure? proc)
  117.       (car (!storage-ref proc 0))
  118.       (error "object not a compound procedure" proc)))
  119.  
  120. (define (compound-procedure-env proc)
  121.   (if (compound-procedure? proc)
  122.       (cadr (!storage-ref proc 0))
  123.       (error "object not a compound procedure" proc)))
  124.  
  125.  
  126.  
  127. ;-------------------------------------------------------------------------------
  128. ;
  129. ; CONTINUATION STRUCTURE
  130. ; ----------------------
  131. ;
  132. ; (#u body-code env-stuff . pspec)
  133. ;
  134. ;      pspec:1 (boxed)    (parameter specifier: exactly 1 argument)
  135. ;  body-code:boxed pointer to 68k code
  136. ;  env-stuff:(Scheme_stack proc_stack state_point . ???)
  137. ;
  138. ;          env:environment in which continuation was created
  139. ;    Scheme_stack:VECTOR containing the Scheme stack during creation
  140. ;      proc_stack:STORAGE containing the processor stack during creation
  141. ;     state_point:the state point during creation
  142. ;
  143. ; All the Scheme registers are pushed onto the Scheme_stack before the
  144. ; vector is created.
  145. ;
  146. ;-------------------------------------------------------------------------------
  147. ;
  148. ; STATE POINT STRUCTURE
  149. ; ---------------------
  150. ;
  151. ; (parent_state_point entry_thunk exit_thunk boxed_interrupt_mask . ???)
  152. ;
  153. ; Note that state points have no special tags; they are just lists.
  154. ; It is not currently intended that they be first-class (or even expressible)
  155. ; in the system.
  156. ;
  157. ;-------------------------------------------------------------------------------
  158.  
  159. (define (dump-continuation cont)
  160.   (if (continuation? cont)
  161.       (list (dump-obj-rep (car (!storage-ref cont 0)))
  162.         (cadr (!storage-ref cont 0)))
  163.       (error "object not a continuation" cont)))
  164.  
  165. (define (dump-continuation-proc-stack cont)
  166.   (let ((cont-dump (dump-continuation cont)))
  167.     (let ((proc-stack (cadr (cadr cont-dump))))
  168.       (let ((proc-stack-rep (!storage-rep-ref proc-stack 0)))
  169.     (let ((byte-size (+ (* #x1000000 (car proc-stack-rep)) (cdr proc-stack-rep))))
  170.       (let ((n-items (inexact->exact (/ byte-size 4))))
  171.         (define (dump-items i item-list)
  172.           (if (< i 1)
  173.           item-list
  174.           (dump-items (- i 1) (cons (!storage-rep-ref proc-stack i) item-list))))
  175.         (dump-items n-items '()) ))))))
  176.  
  177. (define (dump-continuation-Scheme-stack cont)
  178.   (let ((cont-dump (dump-continuation cont)))
  179.     (let ((Scheme-stack (car (cadr cont-dump))))
  180.       Scheme-stack)))
  181.  
  182.  
  183.  
  184. ;-------------------------------------------------------------------------------
  185. ;
  186. ; ENVIRONMENT STRUCTURE
  187. ; ---------------------
  188. ;      env
  189. ;     \
  190. ;      OO
  191. ;     /  \
  192. ;    /    \          To find a binding, search each frame in var-list from
  193. ; var-list  val-list      frame0 for the desired symbol.  If found at frame F,
  194. ;              binding B, then find its value in frame F, binding B
  195. ;              of val-list.
  196. ; var-list
  197. ;   -or-
  198. ; val-list
  199. ;    \
  200. ;     OO-----OO-- - - --OO-nil
  201. ;     |    |       |
  202. ;     |    |       |
  203. ;      frame0 frame1     frameJ-1
  204. ;
  205. ;  frameI
  206. ;     \
  207. ;      OO-----OO-- - - --OO-nil
  208. ;      |      |      |
  209. ;      |      |      |
  210. ;    var0   var1       varK-1
  211. ;    -or-   -or-       -or-
  212. ;    val0   val1       valK-1
  213. ;
  214. ;-------------------------------------------------------------------------------
  215.  
  216. (define (dump-env-var-frame-list env)
  217.   (if (environment? env)
  218.       (!storage-ref env 1)
  219.       (error "object not an environment" env)))
  220.  
  221. (define (dump-env-val-frame-list env)
  222.   (if (environment? env)
  223.       (!storage-ref env 0)
  224.       (error "object not an environment" env)))
  225.  
  226. (define (dump-env env)
  227.   (cons (dump-env-var-frame-list env)
  228.     (dump-env-val-frame-list env)))
  229.  
  230. (define (dump-env-bindings env)
  231.   (map (lambda (var-list val-list)
  232.      (map (lambda (var val)
  233.         (cons var val))
  234.           var-list
  235.           val-list))
  236.        (dump-env-var-frame-list env)
  237.        (dump-env-val-frame-list env)))
  238.  
  239.  
  240.  
  241. ;;; EOF dump.scm
  242.  
  243.